home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src / tclXutil.c < prev   
Encoding:
C/C++ Source or Header  |  1993-11-03  |  16.6 KB  |  599 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCLExtend_2
  3. #endif
  4. /*
  5.  * tclXutil.c
  6.  *
  7.  * Utility functions for Extended Tcl.
  8.  *-----------------------------------------------------------------------------
  9.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  10.  *
  11.  * Permission to use, copy, modify, and distribute this software and its
  12.  * documentation for any purpose and without fee is hereby granted, provided
  13.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14.  * Mark Diekhans make no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without express or
  16.  * implied warranty.
  17.  *-----------------------------------------------------------------------------
  18.  * $Id: tclXutil.c,v 2.10 1993/08/31 23:03:20 markd Exp $
  19.  *-----------------------------------------------------------------------------
  20.  */
  21.  
  22. #ifdef THINK_C
  23. #    include <unix.h>
  24. #endif
  25.  
  26. #include "tclExtdInt.h"
  27.  
  28. #ifndef _tolower
  29. #  define _tolower tolower
  30. #  define _toupper toupper
  31. #endif
  32.  
  33. /*
  34.  * Used to return argument messages by most commands.
  35.  */
  36. char *tclXWrongArgs = "wrong # args: ";
  37.  
  38. #ifndef pow
  39. extern double pow ();
  40. #endif
  41.  
  42.  
  43. /*
  44.  *-----------------------------------------------------------------------------
  45.  *
  46.  * Tcl_StrToLong --
  47.  *      Convert an Ascii string to an long number of the specified base.
  48.  *
  49.  * Parameters:
  50.  *   o string (I) - String containing a number.
  51.  *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
  52.  *     based on the leading characters of the number.  Zero to let the number
  53.  *     determine the base.
  54.  *   o longPtr (O) - Place to return the converted number.  Will be 
  55.  *     unchanged if there is an error.
  56.  *
  57.  * Returns:
  58.  *      Returns 1 if the string was a valid number, 0 invalid.
  59.  *-----------------------------------------------------------------------------
  60.  */
  61. int
  62. Tcl_StrToLong (string, base, longPtr)
  63.     CONST char *string;
  64.     int         base;
  65.     long       *longPtr;
  66. {
  67.     char *end;
  68.     long  num;
  69.  
  70.     num = strtol(string, &end, base);
  71.     while ((*end != '\0') && ISSPACE(*end)) {
  72.         end++;
  73.     }
  74.     if ((end == string) || (*end != 0))
  75.         return FALSE;
  76.     *longPtr = num;
  77.     return TRUE;
  78.  
  79. }
  80.  
  81. /*
  82.  *-----------------------------------------------------------------------------
  83.  *
  84.  * Tcl_StrToInt --
  85.  *      Convert an Ascii string to an number of the specified base.
  86.  *
  87.  * Parameters:
  88.  *   o string (I) - String containing a number.
  89.  *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
  90.  *     based on the leading characters of the number.  Zero to let the number
  91.  *     determine the base.
  92.  *   o intPtr (O) - Place to return the converted number.  Will be 
  93.  *     unchanged if there is an error.
  94.  *
  95.  * Returns:
  96.  *      Returns 1 if the string was a valid number, 0 invalid.
  97.  *-----------------------------------------------------------------------------
  98.  */
  99. int
  100. Tcl_StrToInt (string, base, intPtr)
  101.     CONST char *string;
  102.     int         base;
  103.     int        *intPtr;
  104. {
  105.     char *end;
  106.     int   num;
  107.  
  108.     num = strtol(string, &end, base);
  109.     while ((*end != '\0') && ISSPACE(*end)) {
  110.         end++;
  111.     }
  112.     if ((end == string) || (*end != 0))
  113.         return FALSE;
  114.     *intPtr = num;
  115.     return TRUE;
  116.  
  117. }
  118.  
  119. /*
  120.  *-----------------------------------------------------------------------------
  121.  *
  122.  * Tcl_StrToUnsigned --
  123.  *      Convert an Ascii string to an unsigned int of the specified base.
  124.  *
  125.  * Parameters:
  126.  *   o string (I) - String containing a number.
  127.  *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
  128.  *     based on the leading characters of the number.  Zero to let the number
  129.  *     determine the base.
  130.  *   o unsignedPtr (O) - Place to return the converted number.  Will be 
  131.  *     unchanged if there is an error.
  132.  *
  133.  * Returns:
  134.  *      Returns 1 if the string was a valid number, 0 invalid.
  135.  *-----------------------------------------------------------------------------
  136.  */
  137. int
  138. Tcl_StrToUnsigned (string, base, unsignedPtr)
  139.     CONST char *string;
  140.     int         base;
  141.     unsigned   *unsignedPtr;
  142. {
  143.     char          *end;
  144.     unsigned long  num;
  145.  
  146.     num = strtoul (string, &end, base);
  147.     while ((*end != '\0') && ISSPACE(*end)) {
  148.         end++;
  149.     }
  150.     if ((end == string) || (*end != 0))
  151.         return FALSE;
  152.     *unsignedPtr = num;
  153.     return TRUE;
  154.  
  155. }
  156.  
  157. /*
  158.  *-----------------------------------------------------------------------------
  159.  *
  160.  * Tcl_StrToDouble --
  161.  *   Convert a string to a double percision floating point number.
  162.  *
  163.  * Parameters:
  164.  *   string (I) - Buffer containing double value to convert.
  165.  *   doublePtr (O) - The convert floating point number.
  166.  * Returns:
  167.  *   TRUE if the number is ok, FALSE if it is illegal.
  168.  *-----------------------------------------------------------------------------
  169.  */
  170. int
  171. Tcl_StrToDouble (string, doublePtr)
  172.     CONST char *string;
  173.     double     *doublePtr;
  174. {
  175.     char   *end;
  176.     double  num;
  177.  
  178.     num = strtod (string, &end);
  179.     while ((*end != '\0') && ISSPACE(*end)) {
  180.         end++;
  181.     }
  182.     if ((end == string) || (*end != 0))
  183.         return FALSE;
  184.  
  185.     *doublePtr = num;
  186.     return TRUE;
  187.  
  188. }
  189.  
  190. /*
  191.  *-----------------------------------------------------------------------------
  192.  *
  193.  * Tcl_DownShift --
  194.  *     Utility procedure to down-shift a string.  It is written in such
  195.  *     a way as that the target string maybe the same as the source string.
  196.  *
  197.  * Parameters:
  198.  *   o targetStr (I) - String to store the down-shifted string in.  Must
  199.  *     have enough space allocated to store the string.  If NULL is specified,
  200.  *     then the string will be dynamicly allocated and returned as the
  201.  *     result of the function. May also be the same as the source string to
  202.  *     shift in place.
  203.  *   o sourceStr (I) - The string to down-shift.
  204.  *
  205.  * Returns:
  206.  *   A pointer to the down-shifted string
  207.  *-----------------------------------------------------------------------------
  208.  */
  209. char *
  210. Tcl_DownShift (targetStr, sourceStr)
  211.     char       *targetStr;
  212.     CONST char *sourceStr;
  213. {
  214.     register char theChar;
  215.  
  216.     if (targetStr == NULL)
  217.         targetStr = ckalloc (strlen ((char *) sourceStr) + 1);
  218.  
  219.     for (; (theChar = *sourceStr) != '\0'; sourceStr++) {
  220.         if (isupper (theChar))
  221.             theChar = _tolower (theChar);
  222.         *targetStr++ = theChar;
  223.     }
  224.     *targetStr = '\0';
  225.     return targetStr;
  226. }
  227.  
  228. /*
  229.  *-----------------------------------------------------------------------------
  230.  *
  231.  * Tcl_UpShift --
  232.  *     Utility procedure to up-shift a string.
  233.  *
  234.  * Parameters:
  235.  *   o targetStr (I) - String to store the up-shifted string in.  Must
  236.  *     have enough space allocated to store the string.  If NULL is specified,
  237.  *     then the string will be dynamicly allocated and returned as the
  238.  *     result of the function. May also be the same as the source string to
  239.  *     shift in place.
  240.  *   o sourceStr (I) - The string to up-shift.
  241.  *
  242.  * Returns:
  243.  *   A pointer to the up-shifted string
  244.  *-----------------------------------------------------------------------------
  245.  */
  246. char *
  247. Tcl_UpShift (targetStr, sourceStr)
  248.     char       *targetStr;
  249.     CONST char *sourceStr;
  250. {
  251.     register char theChar;
  252.  
  253.     if (targetStr == NULL)
  254.         targetStr = ckalloc (strlen ((char *) sourceStr) + 1);
  255.  
  256.     for (; (theChar = *sourceStr) != '\0'; sourceStr++) {
  257.         if (ISLOWER (theChar))
  258.             theChar = _toupper (theChar);
  259.         *targetStr++ = theChar;
  260.     }
  261.     *targetStr = '\0';
  262.     return targetStr;
  263. }
  264.  
  265. /*
  266.  *-----------------------------------------------------------------------------
  267.  *
  268.  * Tcl_DStringGets --
  269.  *
  270.  *    Reads a line from a file into a dynamic string.  The string will be
  271.  * expanded, if necessary and reads are done until EOL or EOF is reached.
  272.  * The line is appended to any data already in the string.
  273.  *
  274.  * Parameter
  275.  *   o filePtr (I) - File to read from.
  276.  *   o dynStrPtr (I) - String to return the data in.
  277.  * Returns:
  278.  *    o TCL_BREAK - EOF
  279.  *    o TCL_OK - If data was transfered.
  280.  *    o TCL_ERROR - An error occured.
  281.  *-----------------------------------------------------------------------------
  282.  */
  283. int
  284. Tcl_DStringGets (filePtr, dynStrPtr)
  285.     FILE         *filePtr;
  286.     Tcl_DString  *dynStrPtr;
  287. {
  288.     char           buffer [128];
  289.     register char *bufPtr, *bufEnd;
  290.     register int   readVal;
  291.     int            startLength = dynStrPtr->length;
  292.  
  293.     bufPtr = buffer;
  294.     bufEnd = buffer + sizeof (buffer) - 1;
  295.  
  296.     while (TRUE) {
  297.         readVal = getc (filePtr);
  298.         if (readVal == '\n')      /* Is it a new-line? */
  299.             break;
  300.         if (readVal == EOF)
  301.             break;
  302.         *bufPtr++ = readVal;
  303.         if (bufPtr > bufEnd) {
  304.             Tcl_DStringAppend (dynStrPtr, buffer, sizeof (buffer));
  305.             bufPtr = buffer;
  306.         }
  307.     }
  308.     if ((readVal == EOF) && ferror (filePtr))
  309.         return TCL_ERROR;   /* Error */
  310.  
  311.     if (bufPtr != buffer) {
  312.         Tcl_DStringAppend (dynStrPtr, buffer, bufPtr - buffer);
  313.     }
  314.  
  315.     if ((readVal == EOF) && dynStrPtr->length == startLength)
  316.         return TCL_BREAK;
  317.     else
  318.         return TCL_OK;
  319. }
  320.  
  321. /*
  322.  *-----------------------------------------------------------------------------
  323.  *
  324.  * Tcl_GetLong --
  325.  *
  326.  *      Given a string, produce the corresponding long value.
  327.  *
  328.  * Results:
  329.  *      The return value is normally TCL_OK;  in this case *intPtr
  330.  *      will be set to the integer value equivalent to string.  If
  331.  *      string is improperly formed then TCL_ERROR is returned and
  332.  *      an error message will be left in interp->result.
  333.  *
  334.  * Side effects:
  335.  *      None.
  336.  *
  337.  *-----------------------------------------------------------------------------
  338.  */
  339. int
  340. Tcl_GetLong(interp, string, longPtr)
  341.     Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
  342.     CONST char *string;         /* String containing a (possibly signed)
  343.                                  * integer in a form acceptable to strtol. */
  344.     long       *longPtr;        /* Place to store converted result. */
  345. {
  346.     char *end;
  347.     long  i;
  348.  
  349.     i = strtol(string, &end, 0);
  350.     while ((*end != '\0') && ISSPACE(*end)) {
  351.         end++;
  352.     }
  353.     if ((end == string) || (*end != 0)) {
  354.         Tcl_AppendResult (interp, "expected integer but got \"", string,
  355.                           "\"", (char *) NULL);
  356.         return TCL_ERROR;
  357.     }
  358.     *longPtr = i;
  359.     return TCL_OK;
  360. }
  361.  
  362. /*
  363.  *-----------------------------------------------------------------------------
  364.  *
  365.  * Tcl_GetUnsigned --
  366.  *
  367.  *      Given a string, produce the corresponding unsigned integer value.
  368.  *
  369.  * Results:
  370.  *      The return value is normally TCL_OK;  in this case *intPtr
  371.  *      will be set to the integer value equivalent to string.  If
  372.  *      string is improperly formed then TCL_ERROR is returned and
  373.  *      an error message will be left in interp->result.
  374.  *
  375.  * Side effects:
  376.  *      None.
  377.  *
  378.  *-----------------------------------------------------------------------------
  379.  */
  380. int
  381. Tcl_GetUnsigned(interp, string, unsignedPtr)
  382.     Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
  383.     CONST char *string;         /* String containing a (possibly signed)
  384.                                  * integer in a form acceptable to strtoul. */
  385.     unsigned   *unsignedPtr;    /* Place to store converted result. */
  386. {
  387.     char          *end;
  388.     unsigned long  i;
  389.  
  390.     /*
  391.      * Since some strtoul functions don't detect negative numbers, check
  392.      * in advance.
  393.      */
  394.     while (ISSPACE(*string))
  395.         string++;
  396.     if (string [0] == '-')
  397.         goto badUnsigned;
  398.  
  399.     i = strtoul(string, &end, 0);
  400.     while ((*end != '\0') && ISSPACE(*end))
  401.         end++;
  402.  
  403.     if ((end == string) || (*end != '\0'))
  404.         goto badUnsigned;
  405.  
  406.     *unsignedPtr = i;
  407.     return TCL_OK;
  408.  
  409.   badUnsigned:
  410.     Tcl_AppendResult (interp, "expected unsigned integer but got \"", 
  411.                       string, "\"", (char *) NULL);
  412.     return TCL_ERROR;
  413. }
  414.  
  415. /*
  416.  *-----------------------------------------------------------------------------
  417.  *
  418.  * Tcl_RelativeExpr --
  419.  *
  420.  *    Evaluate an expression that may start with the magic words "end" or
  421.  * "len".  These strings are replaced with either the end offset or the
  422.  * length that is passed in.
  423.  *
  424.  * Parameters:
  425.  *   o interp (I) - A pointer to the interpreter.
  426.  *   o cstringExpr (I) - The expression to evaludate.
  427.  *   o stringLen (I) - The length of the string.
  428.  *   o exprResultPtr (O) - The result of the expression is returned here.
  429.  * Returns:
  430.  *   TCL_OK or TCL_ERROR.
  431.  *-----------------------------------------------------------------------------
  432.  */
  433. int
  434. Tcl_RelativeExpr (interp, cstringExpr, stringLen, exprResultPtr)
  435.     Tcl_Interp  *interp;
  436.     char        *cstringExpr;
  437.     long         stringLen;
  438.     long        *exprResultPtr;
  439. {
  440.     
  441.     char *buf;
  442.     int   exprLen, result;
  443.     char  staticBuf [64];
  444.  
  445.     if (!(STRNEQU (cstringExpr, "end", 3) ||
  446.           STRNEQU (cstringExpr, "len", 3))) {
  447.         return Tcl_ExprLong (interp, cstringExpr, exprResultPtr);
  448.     }
  449.  
  450.     sprintf (staticBuf, "%ld",
  451.              stringLen - ((cstringExpr [0] == 'e') ? 1 : 0));
  452.     exprLen = strlen (staticBuf) + strlen (cstringExpr) - 2;
  453.  
  454.     buf = staticBuf;
  455.     if (exprLen > sizeof (staticBuf)) {
  456.         buf = (char *) ckalloc (exprLen);
  457.         strcpy (buf, staticBuf);
  458.     }
  459.     strcat (buf, cstringExpr + 3);
  460.  
  461.     result = Tcl_ExprLong (interp, buf, exprResultPtr);
  462.  
  463.     if (buf != staticBuf)
  464.         ckfree (buf);
  465.     return result;
  466. }
  467.  
  468. /*
  469.  *-----------------------------------------------------------------------------
  470.  *
  471.  * Tcl_GetOpenFileStruct --
  472.  *
  473.  *    Convert a file handle to a pointer to the internal Tcl file structure.
  474.  *
  475.  * Parameters:
  476.  *   o interp (I) - Current interpreter.
  477.  *   o handle (I) - The file handle to convert.
  478.  * Returns:
  479.  *   A pointer to the open file structure for the file, or NULL if an error
  480.  * occured.
  481.  *-----------------------------------------------------------------------------
  482.  */
  483. OpenFile *
  484. Tcl_GetOpenFileStruct (interp, handle)
  485.     Tcl_Interp *interp;
  486.     char       *handle;
  487. {
  488.     FILE   *filePtr;
  489.  
  490.     if (Tcl_GetOpenFile (interp, handle,
  491.                          FALSE, FALSE,  /* No checking */
  492.                          &filePtr) != TCL_OK)
  493.         return NULL;
  494.  
  495.     return tclOpenFiles [fileno (filePtr)];
  496. }
  497.  
  498. /*
  499.  *-----------------------------------------------------------------------------
  500.  *
  501.  * Tcl_SetupFileEntry --
  502.  *
  503.  * Set up an entry in the Tcl file table for a file number, including the stdio
  504.  * FILE structure.
  505.  *
  506.  * Parameters:
  507.  *   o interp (I) - Current interpreter.
  508.  *   o fileNum (I) - File number to set up the entry for.
  509.  *   o permissions (I) - Flags consisting of TCL_FILE_READABLE,
  510.  *     TCL_FILE_WRITABLE.
  511.  * Returns:
  512.  *   A pointer to the FILE structure for the file, or NULL if an error
  513.  * occured.
  514.  *-----------------------------------------------------------------------------
  515.  */
  516. FILE *
  517. Tcl_SetupFileEntry (interp, fileNum, permissions)
  518.     Tcl_Interp *interp;
  519.     int         fileNum;
  520.     int         permissions;
  521. {
  522.     Interp   *iPtr = (Interp *) interp;
  523.     char     *mode;
  524.     FILE     *filePtr;
  525.  
  526.     /*
  527.      * Set up a stdio FILE control block for the new file.
  528.      */
  529.     if (permissions & TCL_FILE_WRITABLE) {
  530.         if (permissions & TCL_FILE_READABLE)
  531.             mode = "r+";
  532.         else
  533.             mode = "w";
  534.     } else {
  535.         mode = "r";
  536.     }
  537.  
  538.     filePtr = fdopen (fileNum, mode);
  539.     if (filePtr == NULL) {
  540.         iPtr->result = Tcl_PosixError (interp);
  541.         return NULL;
  542.     }
  543.     
  544.     Tcl_EnterFile (interp, filePtr, permissions);
  545.  
  546.     return filePtr;
  547. }
  548.  
  549. /*
  550.  *-----------------------------------------------------------------------------
  551.  *
  552.  * Tcl_CloseForError --
  553.  *
  554.  *   Close a file number on error.  If the file is in the Tcl file table, clean
  555.  * it up too. The variable errno, and interp->result and the errorCode variable
  556.  * will be saved and not lost.
  557.  *
  558.  * Parameters:
  559.  *   o interp (I) - Current interpreter.
  560.  *   o fileNum (I) - File number to close.
  561.  *-----------------------------------------------------------------------------
  562.  */
  563. void
  564. Tcl_CloseForError (interp, fileNum)
  565.     Tcl_Interp *interp;
  566.     int         fileNum;
  567. {
  568.     static char *ERROR_CODE = "errorCode";
  569.     int          saveErrNo = errno;
  570.     char        *saveResult, *errorCode, *saveErrorCode, *argv [2], buf [32];
  571.  
  572.     saveResult = ckstrdup (interp->result);
  573.  
  574.     errorCode = Tcl_GetVar (interp, ERROR_CODE, TCL_GLOBAL_ONLY);
  575.     if (errorCode != NULL)
  576.         saveErrorCode = ckstrdup (errorCode);
  577.     else
  578.         saveErrorCode = NULL;
  579.  
  580.     sprintf (buf, "file%d", fileNum);
  581.  
  582.     argv [0] = "close";
  583.     argv [1] = buf;
  584.     Tcl_CloseCmd (NULL, interp, 2, argv);
  585.     Tcl_ResetResult (interp);
  586.  
  587.     if (saveErrorCode != NULL) {
  588.         Tcl_SetVar (interp, ERROR_CODE, saveErrorCode, TCL_GLOBAL_ONLY);
  589.         free (saveErrorCode);
  590.     }
  591.     Tcl_SetResult (interp, saveResult, TCL_VOLATILE);
  592.     free (saveResult);
  593.  
  594.     close (fileNum);  /* In case Tcl didn't have it open */
  595.     
  596.     errno = saveErrNo;
  597. }
  598.      
  599.